home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Moscow ML 1.31 / source code / mosml / src / runtime / mosml.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-03  |  19.2 KB  |  886 lines  |  [TEXT/R*ch]
  1. /* Moscow SML primitives */
  2.  
  3. #include <math.h>
  4. #include <sys/time.h>
  5. #include <sys/times.h>
  6. #include <sys/resource.h>
  7. #include <dirent.h>
  8. #include <errno.h>
  9. #include <stdio.h>
  10. #include <stdlib.h>
  11. #include <sys/param.h> 
  12. #include <sys/stat.h>
  13. #include <time.h>
  14. #include <unistd.h>
  15. #include <utime.h>
  16. #include "fail.h"
  17. #include "memory.h"
  18. #include "str.h"
  19. #include "runtime.h"
  20.  
  21. #if defined(sun) && !defined(__svr4__)
  22. #define tm2cal(tptr)    timelocal(tptr)
  23. #else
  24. #define tm2cal(tptr)    mktime(tptr)
  25. #endif
  26.  
  27. #define Raise_float_if(cond) \
  28.    if( cond ) \
  29.       { mlraise(Atom(float_exn)); }
  30.  
  31. #define Check_float(dval) \
  32.    Raise_float_if( (dval > maxdouble) || (dval < -maxdouble) )
  33.  
  34. /* Structural equality on trees. */
  35. /* Note how reference cells are treated! */
  36.  
  37. static int sml_equal_aux(v1, v2)
  38.      value v1,v2;
  39. {
  40.   mlsize_t i;
  41.   value * p1, * p2;
  42.  
  43.  again:
  44.   if (v1 == v2) return 1;
  45.   if (Is_long(v1) || Is_long(v2)) return 0;
  46.   if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
  47.   if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
  48.   if (Tag_val(v1) != Tag_val(v2)) return 0;
  49.   switch(Tag_val(v1)) {
  50.   case String_tag:
  51.     return (compare_strings(v1, v2) == Val_long(0));
  52.   case Double_tag:
  53.     return (Double_val(v1) == Double_val(v2));
  54.   case Reference_tag:  /* Different reference cells are not equal! */
  55.   case Abstract_tag:
  56.   case Final_tag:
  57.     return 0;
  58.   case Closure_tag:
  59.     invalid_argument("sml_equal: functional value");
  60.   default:
  61.     i = Wosize_val(v1);
  62.     if (i != Wosize_val(v2)) return 0;
  63.     for(p1 = Op_val(v1), p2 = Op_val(v2);
  64.         i > 1;
  65.         i--, p1++, p2++)
  66.       if (!sml_equal_aux(*p1, *p2)) return 0;
  67.     v1 = *p1;
  68.     v2 = *p2;                   /* Tail-call */
  69.     goto again;
  70.   }
  71. }
  72.  
  73. value sml_equal(v1, v2) /* ML */
  74.      value v1, v2;
  75. {
  76.   return Atom(sml_equal_aux(v1,v2));
  77. }
  78.  
  79. value sml_not_equal(v1, v2) /* ML */
  80.      value v1, v2;
  81. {
  82.   return Atom(!sml_equal_aux(v1,v2));
  83. }
  84.  
  85. value sml_system(cmd)        /* ML */
  86.      value cmd;
  87. {
  88.   return Val_int(system(String_val(cmd)));
  89. }
  90.  
  91. value sml_abs_int(x)          /* ML */
  92.     value x;
  93. { value tmp, v;
  94.   tmp = Long_val(x);
  95.   if( tmp < 0 ) tmp = -tmp;
  96.   v = Val_long(tmp);
  97.   if( Long_val(v) != tmp )
  98.     mlraise(Atom(SMLEXN_OVF));
  99.   return v;
  100. }
  101.  
  102. value sml_floor(f)              /* ML */
  103.      value f;
  104. { double r;
  105.   long i;
  106.   value v;
  107.   r = Double_val(f);
  108.   if( r >= 0.0 )
  109.     { if( r >= ((double) (Max_long+1)) ) goto raise_floor;
  110.       i = (long) r;
  111.     }
  112.   else
  113.     { if( r < ((double) Min_long) ) goto raise_floor;
  114.       i = (long) r;
  115.       if( r < ((double) i) ) i -= 1;
  116.     }
  117.   v = Val_long(i);
  118.   if( Long_val(v) != i )  goto raise_floor;
  119.   return v;
  120.  
  121. raise_floor:
  122.     mlraise(Atom(SMLEXN_OVF));
  123. }
  124.  
  125. value sml_abs_real(f)              /* ML */
  126.      value f;
  127. { double r;
  128.   float_exn = SMLEXN_OVF;
  129.   r = Double_val(f);
  130.   if( r >= 0.0 )
  131.     return f;
  132.   else
  133.     r = -r;
  134.     Check_float(r);
  135.     return copy_double(r);
  136. }
  137.  
  138. value sml_sqrt(f)         /* ML */
  139.      value f;
  140. { double r;
  141.   float_exn = SMLEXN_SQRT;
  142.   r = Double_val(f);
  143.   Raise_float_if( r < 0.0 );
  144.   r = sqrt(r);
  145.   Check_float(r);
  146.   return copy_double(r);
  147. }
  148.  
  149. value sml_sin(f)         /* ML */
  150.      value f;
  151. { double r;
  152.   r = Double_val(f);
  153.   r = sin(r);
  154.   if( r != r || r > 1.0 || r < -1.0 )
  155.     failwith("sin: argument too large");
  156.   return copy_double(r);
  157. }
  158.  
  159. value sml_cos(f)         /* ML */
  160.      value f;
  161. { double r;
  162.   r = Double_val(f);
  163.   r = cos(r);
  164.   if( r != r || r > 1.0 || r < -1.0 )
  165.     failwith("cos: argument too large");
  166.   return copy_double(r);
  167. }
  168.  
  169. value sml_exp(f)           /* ML */
  170.      value f;
  171. { double r;
  172.   float_exn = SMLEXN_OVF;
  173.   r = exp(Double_val(f));
  174.   Check_float(r);
  175.   return copy_double(r);
  176. }
  177.  
  178. value sml_ln(f)           /* ML */
  179.      value f;
  180. { double r;
  181.   float_exn = SMLEXN_LN;
  182.   r = Double_val(f);
  183.   Raise_float_if( r <= 0.0 );
  184.   r = log(r);
  185.   Check_float(r);
  186.   return copy_double(r);
  187. }
  188.  
  189. value sml_int_of_string(s)          /* ML */
  190.      value s;
  191. { value v;
  192.   long res;
  193.   int sign;
  194.   char * p;
  195.   int c, d;
  196.  
  197.   p = String_val(s);
  198.   sign = 1;
  199.   if (*p == '~') {
  200.     sign = -1;
  201.     p++;
  202.   }
  203.   res = 0;
  204.   while (1) {
  205.     c = *p;
  206.     if (c >= '0' && c <= '9')
  207.       d = c - '0';
  208.     else
  209.       break;
  210.     if( (res > (Max_long/10)) ||
  211.         ((res == (Max_long/10) && ((Max_long % 10 + 1) < d))) )
  212.       goto raise_failure;
  213.     res = 10 * res + d;
  214.     p++;
  215.   }
  216.   if (*p != 0)
  217.     goto raise_failure;
  218.   if( sign < 0 ) res = -res;
  219.   v = Val_long(res);
  220.   if( Long_val(v) != res )
  221.     goto raise_failure;
  222.   return v;
  223.  
  224.   raise_failure:
  225.     failwith("sml_int_of_string");
  226. }
  227.  
  228. value sml_concat(s1, s2)        /* ML */
  229.      value s1, s2;
  230. {
  231.   mlsize_t len1, len2, len;
  232.   value s;
  233.   Push_roots(r, 2);
  234.   r[0] = s1;
  235.   r[1] = s2;
  236.   len1 = string_length(s1);
  237.   len2 = string_length(s2);
  238.   len = len1 + len2;
  239.   if( (len + sizeof (value)) / sizeof (value) > Max_wosize )
  240.     mlraise(Atom(END_OF_FILE_EXN)); /* This translates to exn Size! 
  241.                        See src/compiler/Smlexc.sml */
  242.   s = alloc_string(len);
  243.   bcopy(&Byte(r[0],0), &Byte(s,0), len1);
  244.   bcopy(&Byte(r[1],0), &Byte(s,len1), len2);
  245.   Pop_roots();
  246.   return s;
  247. }
  248.  
  249. value sml_chr(v)          /* ML */
  250.      value v;
  251. {
  252.   long i;
  253.   value s;
  254.   i = Long_val(v);
  255.   if( i < 0 || i > 255 )
  256.     mlraise(Atom(SMLEXN_CHR));
  257.   s = alloc_string(1);
  258.   *(&Byte(s,0)) = (unsigned char) i;
  259.   return s;
  260. }
  261.  
  262. value sml_ord(s)          /* ML */
  263.      value s;
  264. {
  265.   long i;
  266.   if( string_length(s) == 0 )
  267.     mlraise(Atom(SMLEXN_ORD));
  268.   i = (unsigned char) *(&Byte(s,0));
  269.   return Val_long(i);
  270. }
  271.  
  272. value sml_float_of_string(s)        /* ML */
  273.      value s;
  274. {
  275.  
  276.   char buff[64];
  277.   mlsize_t len;
  278.   int i, e_len;
  279.   char c;
  280.   char *p;
  281.   double r;
  282.  
  283.   len = string_length(s);
  284.   if(len > sizeof(buff) - 1)
  285.     failwith("sml_float_of_string: argument too large");
  286.   p = String_val(s);
  287.   e_len = -1;
  288.   for (i = 0; i<len; i++) {
  289.     c = *p++;
  290.     switch( c ) {
  291.         case '~':
  292.           buff[i] = '-'; break;
  293.         case 'E':
  294.           buff[i] = 'e'; e_len = 0; break;
  295.         default:
  296.           buff[i] = c;
  297.           if( e_len >= 0 ) e_len++;
  298.           Raise_float_if( e_len > 5 )
  299.           break;
  300.     }
  301.   }
  302.   buff[len] = 0;
  303.   r = atof(buff);
  304.   if( (r > maxdouble) || (r < -maxdouble) )
  305.     failwith("sml_float_of_string: result too large");
  306.   return copy_double(r);
  307. }
  308.  
  309.  
  310. static int countChar(c, s)
  311.    int c; char* s;
  312. {
  313.   char *p; int count;
  314.  
  315.   count = 0;
  316.   for( p=s; *p != '\0'; p++ ) {
  317.     if( *p == c ) count++;
  318.   }
  319.   return count;
  320. }
  321.  
  322. /* Here we remove all '+', and replace '-' and 'e' */
  323. /* with '~' and 'E', respectively. */
  324.  
  325. static void mkSMLMinus(s)
  326.   char *s;
  327. {
  328.   char *p, *q;
  329.  
  330.   for( p=s, q=s; *p != '\0'; p++ ) {
  331.     switch( *p ) {
  332.         case '+': break;
  333.         case '-': *q++ = '~'; break;
  334.         case 'e': *q++ = 'E'; break;
  335.         default: *q++ = *p;
  336.     }
  337.   }
  338.   *q = '\0';
  339.   return;
  340. }
  341.  
  342. value sml_string_of_int(arg)      /* ML */
  343.      value arg;
  344. {
  345.   char format_buffer[32];
  346.  
  347.   sprintf(format_buffer, "%ld", Long_val(arg));
  348.   mkSMLMinus(format_buffer);
  349.   return copy_string(format_buffer);
  350. }
  351.  
  352. value sml_string_of_float(arg)    /* ML */
  353.      value arg;
  354. {
  355.   char format_buffer[64];
  356.  
  357.   sprintf(format_buffer, "%.12g", Double_val(arg));
  358.   mkSMLMinus(format_buffer);
  359.   if( countChar('.', format_buffer) == 0 &&
  360.       countChar('E', format_buffer) == 0 )
  361.     strcat(format_buffer, ".0");
  362.   return copy_string(format_buffer);
  363. }
  364.  
  365. #ifdef __MWERKS__
  366. #pragma mpwc_newline on
  367. #endif
  368.  
  369. value sml_makestring_of_char(arg)      /* ML */
  370.      value arg;
  371. {
  372.   unsigned char c;
  373.   char buff[8];
  374.  
  375.   c = Int_val(arg);
  376.   switch (c)
  377.     {
  378.     case '"':   return copy_string("#\"\\\"\"");
  379.     case '\\':  return copy_string("#\"\\\\\"");
  380.     case '\n':  return copy_string("#\"\\n\"");
  381.     case '\t':  return copy_string("#\"\\t\"");
  382.     default:
  383.       buff[0] = '#'; buff[1] = '"';
  384.       if( c <= 31 ) {
  385.         buff[2] = '\\'; buff[3] = '^'; buff[4] = c + 64;
  386.         buff[5] = '"'; buff[6] = 0;
  387.         return copy_string(buff);
  388.         }
  389.       else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) ) {
  390.         buff[2] = c; buff[3] = '"'; buff[4] = 0;
  391.         return copy_string(buff);
  392.         }
  393.       else {
  394.         buff[2] = '\\';
  395.         buff[3] = 48 + c / 100;
  396.         buff[4] = 48 + (c / 10) % 10;
  397.         buff[5] = 48 + c % 10;
  398.         buff[6] = '"';
  399.         buff[7] = 0;
  400.         return copy_string(buff);
  401.         }
  402.     }
  403. }
  404.  
  405. value sml_makestring_of_string(arg)      /* ML */
  406.      value arg;
  407. {
  408.   mlsize_t arg_len, len, i;
  409.   value res;
  410.   char *a; char *b;
  411.   unsigned char c;
  412.   Push_roots(r, 1);
  413.  
  414.   r[0] = arg;
  415.   arg_len = string_length(arg);
  416.  
  417.   a = String_val(r[0]);
  418.   len = 0;
  419.   for( i = 0; i < arg_len; i++ ) {
  420.     c = a[i];
  421.     switch (c)
  422.       {
  423.       case '"': case '\\': case '\n': case '\t':
  424.         len += 2; break;
  425.       default:
  426.         if( c <= 31)
  427.           len += 3;
  428.         else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
  429.           len += 1;
  430.         else
  431.           len += 4;
  432.         break;
  433.       }
  434.     }
  435.  
  436.   if( (len + 2 + sizeof (value)) / sizeof (value) > Max_wosize )
  437.     failwith("sml_string_for_read: result too large");
  438.   res = alloc_string(len + 2);
  439.  
  440.   a = String_val(r[0]);
  441.   b = String_val(res);
  442.   *b++ = '"';
  443.   for( i = 0; i < arg_len; i++) {
  444.     c = a[i];
  445.     switch (c)
  446.       {
  447.       case '"':   *b++ = '\\'; *b++ = '"';  break;
  448.       case '\\':  *b++ = '\\'; *b++ = '\\'; break;
  449.       case '\n':  *b++ = '\\'; *b++ = 'n';  break;
  450.       case '\t':  *b++ = '\\'; *b++ = 't';  break;
  451.       default:
  452.         if( c <= 31 )
  453.           { *b++ = '\\'; *b++ = '^'; *b++ = c + 64; break; }
  454.         else if( (32 <= c && c <= 126) || (128 <= c && c <= 254) )
  455.           { *b++ = c; break; }
  456.         else
  457.           { *b++ = '\\';
  458.             *b++ = 48 + c / 100;
  459.             *b++ = 48 + (c / 10) % 10;
  460.             *b++ = 48 + c % 10;
  461.             break; }
  462.       }
  463.     }
  464.   *b++ = '"';
  465.   Pop_roots();
  466.   return res;
  467. }
  468.  
  469. #ifdef __MWERKS__
  470. #pragma mpwc_newline off
  471. #endif
  472.  
  473. /* The following must agree with timebase in mosmllib/Time.sml: */
  474.  
  475. #define TIMEBASE (-1073741824)
  476.  
  477. /* There is another problem on the Mac: with a time base of 1904,
  478.    most times are simply out of range of mosml integers. So, I added
  479.    the macros below to compensate. 07Sep95 e
  480. */
  481.  
  482. #ifdef macintosh
  483.  
  484. /* 28Jan93   Kjeld & Soren */
  485. #define TMacbaseyr      1904L
  486. #define TUNIXbaseyr     1970L
  487. /* number of leap days between the two years -- Mac base was a leap year! */
  488. #define TLpD    ((TUNIXbaseyr-TMacbaseyr-1)/4) + 1
  489. /* TimeBaseDif is the number of seconds between Mac and UNIX time (GMT) */
  490. #define TimeBaseDif     ((((TUNIXbaseyr-TMacbaseyr)*365)+TLpD)*24*60*60)
  491.  
  492. #define SYStoSMLtime(m) ((m) - TimeBaseDif)
  493. #define SMLtoSYStime(s) ((s) + TimeBaseDif)
  494.  
  495. #else
  496.  
  497. #define SYStoSMLtime
  498. #define SMLtoSYStime
  499.  
  500. #endif
  501.  
  502. value sml_getrealtime (v) /* ML */
  503.     value v;
  504. {
  505.   value res;
  506.   struct timeval tp;
  507.  
  508.   gettimeofday(&tp, NULL);
  509.   res = alloc (2, 0);
  510.   Field (res, 0) = Val_long (SYStoSMLtime(tp.tv_sec)+TIMEBASE);
  511.   Field (res, 1) = Val_long (tp.tv_usec);
  512.   return res;
  513. }
  514.  
  515. value sml_getrutime (v) /* ML */
  516.     value v;
  517. {
  518.   value res;
  519.  
  520. #if defined(__MWERKS__)
  521.   res = e_getrusage();
  522. #else
  523. #if defined(hpux) || defined(__svr4__)
  524.   struct tms buffer;
  525.  
  526.   long persec = sysconf(_SC_CLK_TCK);
  527.   times(&buffer);
  528.   res = alloc (6, 0);
  529.   Field (res, 2) = Val_long (buffer.tms_stime / persec);
  530.   Field (res, 3) = Val_long ((buffer.tms_stime % persec) * (1000000 / persec));
  531.   Field (res, 4) = Val_long (buffer.tms_utime / persec);
  532.   Field (res, 5) = Val_long ((buffer.tms_utime % persec) * (1000000 / persec));
  533. #else
  534.   struct rusage rusages;
  535.   getrusage(RUSAGE_SELF, &rusages);
  536.   res = alloc (6, 0);
  537.   Field (res, 2) = Val_long (rusages.ru_stime.tv_sec);
  538.   Field (res, 3) = Val_long (rusages.ru_stime.tv_usec);
  539.   Field (res, 4) = Val_long (rusages.ru_utime.tv_sec); 
  540.   Field (res, 5) = Val_long (rusages.ru_utime.tv_usec);
  541. #endif
  542.  
  543.   Field (res, 0) = Val_long (gc_time.tv_sec);
  544.   Field (res, 1) = Val_long (gc_time.tv_usec); 
  545. #endif
  546.  
  547.   return res;
  548. }
  549.  
  550.  
  551. value sml_errno(arg)          /* ML */
  552.      value arg;
  553. {
  554.   return Val_long(errno);
  555. }
  556.  
  557. value sml_getdir(arg)        /* ML */
  558.      value arg;
  559. {
  560.  char directory[MAXPATHLEN];
  561.  char *res;
  562.  
  563.  errno = 0;
  564.  res = getcwd(directory, MAXPATHLEN);
  565.  if (res == NULL)
  566.     failwith("getcwd");
  567.  return copy_string(directory);
  568. }
  569.  
  570. value sml_mkdir(path)          /* ML */
  571.      value path;
  572. {
  573.   if (mkdir(String_val(path), 0777) == -1) 
  574.       failwith("mkdir");
  575.   return Val_unit;
  576. }
  577.  
  578. value sml_rmdir(path)          /* ML */
  579.      value path;
  580. {
  581.   if (rmdir(String_val(path)) == -1) 
  582.       failwith("rmdir");
  583.   return Val_unit;
  584. }
  585.  
  586. value sml_opendir(path)          /* ML */
  587.      value path;
  588. { DIR * dstr;
  589.  
  590.   dstr = opendir(String_val(path));
  591.   if (dstr == NULL)
  592.       failwith("opendir");
  593. #ifdef MSDOS
  594.   if (readdir(dstr) == NULL) 
  595.       failwith("opendir");
  596.   else
  597.       rewinddir(dstr);
  598. #endif
  599.   return (value) dstr;
  600. }
  601.  
  602. value sml_rewinddir(v)          /* ML */
  603.      value v;
  604. { 
  605.   rewinddir((DIR *) v);
  606.   return Val_unit;
  607. }
  608.  
  609. value sml_readdir(v)          /* ML */
  610.      value v;
  611. { struct dirent *direntry;
  612.  
  613.   direntry = readdir((DIR *) v);
  614.   if (direntry == NULL) 
  615.       return copy_string("");
  616.   return copy_string((*direntry).d_name);
  617. }
  618.  
  619. value sml_closedir(v)          /* ML */
  620.      value v;
  621. { 
  622.   if (closedir((DIR *) v) == -1)
  623.       failwith("closedir");
  624.   return Val_unit;
  625. }
  626.  
  627. value sml_isdir(path)          /* ML */
  628.      value path;
  629. { struct stat buf;
  630.  
  631.   if (stat(String_val(path), &buf) == -1)
  632.       failwith("stat");
  633.   return (Val_bool(S_ISDIR(buf.st_mode)));
  634. }
  635.  
  636. value sml_modtime(path)          /* ML */
  637.      value path;
  638. { struct stat buf;
  639.  
  640.   if (stat(String_val(path), &buf) == -1)
  641.       failwith("stat");
  642.   return (copy_double ((double) (SYStoSMLtime(buf.st_mtime))));
  643. }
  644.  
  645. value sml_settime(path, time)          /* ML */
  646.      value path, time;
  647. { struct utimbuf tbuf;
  648.  
  649.   tbuf.actime = tbuf.modtime = SMLtoSYStime((long) (Double_val(time)));
  650.   if (utime(String_val(path), &tbuf) == -1)
  651.       failwith("utime");
  652.   return Val_unit;
  653. }
  654.  
  655. value sml_access(path, permarg)          /* ML */
  656.      value path, permarg;
  657. { long perms;
  658.   long perm = Long_val(permarg);
  659.  
  660.   perms  = ((0x1 & perm) ? R_OK : 0);
  661.   perms |= ((0x2 & perm) ? W_OK : 0);
  662.   perms |= ((0x4 & perm) ? X_OK : 0);
  663.   if (perms == 0) perms = F_OK;
  664.  
  665.   if (access(String_val(path), perms) == 0)
  666.     return Val_bool(1);
  667.   return Val_bool(0);
  668. }
  669.  
  670. #ifndef HAS_STRERROR
  671.   extern int sys_nerr;
  672.   extern char * sys_errlist [];
  673.   extern char *realpath();
  674.   char *mktemp();
  675. #endif
  676.  
  677. value sml_mktemp(v)          /* ML */
  678.      value v;
  679. { char name[256];
  680.   char *res;
  681.  
  682.   if (string_length(v) > 255) 
  683.     failwith("bcopy");
  684.   bcopy(String_val(v), name, string_length(v)+1);
  685.   res = mktemp(name);
  686.   if (res == NULL) 
  687.     failwith("mktemp");  
  688.   return copy_string(name);
  689. }
  690.  
  691. value sml_errormsg(err)   /* ML */
  692.      value err;
  693. {
  694.   int errnum;
  695.   errnum = Long_val(err);
  696. #ifdef HAS_STRERROR
  697.   return copy_string(strerror(errnum));
  698. #else
  699.   if (errnum < 0 || errnum >= sys_nerr) 
  700.       return copy_string("(Unknown error)");
  701.   else 
  702.     return copy_string(sys_errlist[errnum]);
  703. #endif
  704. }
  705.  
  706. value sml_asin(f)           /* ML */
  707.      value f;
  708. { double r = Double_val(f);
  709.   float_exn = SMLEXN_TRIG;
  710.   Raise_float_if( r < -1.0 || r > 1.0 );  
  711.   r = asin(r);
  712.   Raise_float_if( r != r );
  713.   return copy_double(r);
  714. }
  715.  
  716. value sml_acos(f)           /* ML */
  717.      value f;
  718. { double r = Double_val(f);
  719.   float_exn = SMLEXN_TRIG;
  720.   Raise_float_if( r < -1.0 || r > 1.0 );  
  721.   r = acos(r);
  722.   Raise_float_if( r != r );
  723.   return copy_double(r);
  724. }
  725.  
  726. value sml_atan2(f1, f2)           /* ML */
  727.      value f1, f2;
  728. { double r, r1, r2;
  729.   float_exn = SMLEXN_TRIG;
  730.   r1 = Double_val(f1);
  731.   r2 = Double_val(f2);
  732.   if (r1 == 0.0 && r2 == 0.0) 
  733.     return copy_double(0.0);
  734.   r = atan2(r1, r2);
  735.   Check_float(r);
  736.   Raise_float_if( r != r );
  737.   return copy_double(r);
  738. }
  739.  
  740. value sml_pow(f1, f2)           /* ML */
  741.      value f1, f2;
  742. { double r, r1, r2;
  743.   float_exn = SMLEXN_OVF;
  744.   r1 = Double_val(f1);
  745.   r2 = Double_val(f2);
  746.   if (r1 == 0.0 && r2 == 0.0) 
  747.     return copy_double(1.0);
  748.   r = pow(r1, r2);
  749.   Check_float(r);
  750.   Raise_float_if( r != r );
  751.   return copy_double(r);
  752. }
  753.  
  754. value sml_localtime (v) /* ML */
  755.     value v;
  756. {
  757.   value res;
  758.   struct tm *tmr;
  759.   time_t clock = SMLtoSYStime((long) (Double_val(v)));
  760.   tmr = localtime(&clock);
  761.   res = alloc (9, 0);
  762.   Field (res, 0) = Val_long ((*tmr).tm_hour);
  763.   Field (res, 1) = Val_long ((*tmr).tm_isdst);
  764.   Field (res, 2) = Val_long ((*tmr).tm_mday);
  765.   Field (res, 3) = Val_long ((*tmr).tm_min); 
  766.   Field (res, 4) = Val_long ((*tmr).tm_mon);
  767.   Field (res, 5) = Val_long ((*tmr).tm_sec);
  768.   Field (res, 6) = Val_long ((*tmr).tm_wday);
  769.   Field (res, 7) = Val_long ((*tmr).tm_yday);
  770.   Field (res, 8) = Val_long ((*tmr).tm_year);
  771.  
  772.   return res;
  773. }
  774.  
  775. value sml_gmtime (v) /* ML */
  776.     value v;
  777. {
  778.   value res;
  779.   struct tm *tmr;
  780.   time_t clock = SMLtoSYStime((long) (Double_val(v)));
  781.   tmr = gmtime(&clock);
  782.   res = alloc (9, 0);
  783.   Field (res, 0) = Val_long ((*tmr).tm_hour);
  784.   Field (res, 1) = Val_long ((*tmr).tm_isdst);
  785.   Field (res, 2) = Val_long ((*tmr).tm_mday);
  786.   Field (res, 3) = Val_long ((*tmr).tm_min); 
  787.   Field (res, 4) = Val_long ((*tmr).tm_mon);
  788.   Field (res, 5) = Val_long ((*tmr).tm_sec);
  789.   Field (res, 6) = Val_long ((*tmr).tm_wday);
  790.   Field (res, 7) = Val_long ((*tmr).tm_yday);
  791.   Field (res, 8) = Val_long ((*tmr).tm_year);
  792.   return res;
  793. }
  794.  
  795. value sml_mktime (v) /* ML */
  796.     value v;
  797. {
  798.   struct tm tmr;
  799.  
  800.   tmr.tm_hour  = Long_val(Field (v, 0));
  801.   tmr.tm_isdst = Long_val(Field (v, 1));
  802.   tmr.tm_mday  = Long_val(Field (v, 2));
  803.   tmr.tm_min   = Long_val(Field (v, 3));
  804.   tmr.tm_mon   = Long_val(Field (v, 4));
  805.   tmr.tm_sec   = Long_val(Field (v, 5));
  806.   tmr.tm_wday  = Long_val(Field (v, 6));
  807.   tmr.tm_yday  = Long_val(Field (v, 7));
  808.   tmr.tm_year  = Long_val(Field (v, 8));
  809.  
  810.   return copy_double((double)SYStoSMLtime(tm2cal(&tmr)));
  811.  
  812. }
  813.  
  814. value sml_asctime (v) /* ML */
  815.     value v;
  816. {
  817.   struct tm tmr;
  818.   char *res;
  819.  
  820.   tmr.tm_hour  = Long_val(Field (v, 0));
  821.   tmr.tm_isdst = Long_val(Field (v, 1));
  822.   tmr.tm_mday  = Long_val(Field (v, 2));
  823.   tmr.tm_min   = Long_val(Field (v, 3));
  824.   tmr.tm_mon   = Long_val(Field (v, 4));
  825.   tmr.tm_sec   = Long_val(Field (v, 5));
  826.   tmr.tm_wday  = Long_val(Field (v, 6));
  827.   tmr.tm_yday  = Long_val(Field (v, 7));
  828.   tmr.tm_year  = Long_val(Field (v, 8));
  829.  
  830.   tm2cal(&tmr);
  831.  
  832.   res = asctime(&tmr);
  833.   if (res == NULL) 
  834.       failwith("asctime");
  835.   return copy_string(res);
  836. }
  837.  
  838. value sml_strftime (fmt, v) /* ML */
  839.     value fmt, v;
  840. {
  841.   struct tm tmr;
  842. #define BUFSIZE 256      
  843.   char buf[BUFSIZE];
  844.   long ressize;
  845.  
  846.   tmr.tm_hour  = Long_val(Field (v, 0));
  847.   tmr.tm_isdst = Long_val(Field (v, 1));
  848.   tmr.tm_mday  = Long_val(Field (v, 2));
  849.   tmr.tm_min   = Long_val(Field (v, 3));
  850.   tmr.tm_mon   = Long_val(Field (v, 4));
  851.   tmr.tm_sec   = Long_val(Field (v, 5));
  852.   tmr.tm_wday  = Long_val(Field (v, 6));
  853.   tmr.tm_yday  = Long_val(Field (v, 7));
  854.   tmr.tm_year  = Long_val(Field (v, 8));
  855.  
  856.   tm2cal(&tmr);
  857.  
  858.   ressize = strftime(buf, BUFSIZE, String_val(fmt), &tmr);
  859.   if (ressize == 0 || ressize == BUFSIZE) 
  860.       failwith("strftime");
  861.   return copy_string(buf);
  862. #undef BUFSIZE
  863. }
  864.  
  865. value sml_general_string_of_float(fmt, arg)    /* ML */
  866.      value fmt, arg;
  867. {
  868. #define BUFSIZE 512
  869.   char format_buffer[BUFSIZE];
  870.   int i;
  871.  
  872.   /* Unfortunately there seems to be no way to ensure that this does not
  873.    * crash by overflowing the format_buffer (e.g. when specifying a huge 
  874.    * number of decimal digits in the fixed-point format): 
  875.    */
  876.  
  877.   sprintf(format_buffer, String_val(fmt), Double_val(arg));
  878.  
  879.   mkSMLMinus(format_buffer);
  880.   if( countChar('.', format_buffer) == 0 &&
  881.       countChar('E', format_buffer) == 0 )
  882.     strcat(format_buffer, ".0");
  883.   return copy_string(format_buffer);
  884. #undef BUFSIZE
  885. }
  886.